(defun skill (intention)
  (find-skill-from-id (intention-id intention)))

(defvar *wrapper->skill-list* NIL)
(defvar *recursive-base->recursive-case-skill* NIL)

(defstruct (recursive-sclause (:include sclause))
  conditions-intersection
  effects-intersection
)

;; Given a set of conditions for the base skill/case, and a set of conditions for the recursive
;; case, the intersection is what we use to determine if we're going to call one or the other
;; (the base case or the recursive case) until the call is actually made.
;; That is, if rm-x is a subskill, we don't know whether the recursive case will be called or
;; the base case, so the condition/effect contribution to the new macro of which this is a
;; subskill, is the intersection of rm-x's conditions/effects.
(defun intersect-conds&effects (recursive-base-skill new-args conditions effects)
  (let* ((temps (loop for x in new-args collect (gensym)))
	 (base-bindings (loop for var in (rest (sclause-head recursive-base-skill))
			   for temp in temps
			   collect `(,var . ,temp)))
	 (new-arg-bindings (loop for var in new-args
			      for temp in temps
			      collect `(,var . ,temp)))
	 (base-skill-conds-bound (subst-bindings base-bindings 
						 (sclause-conditions recursive-base-skill)))
	 (conditions-bound (subst-bindings new-arg-bindings conditions))
	 (base-skill-effects-bound (subst-bindings base-bindings
						   (sclause-effects recursive-base-skill)))
	 (effects-bound (subst-bindings new-arg-bindings effects))
	 (conditions-intersect (intersection base-skill-conds-bound conditions-bound
					     :test #'equal))
	 (effects-intersect (intersection base-skill-effects-bound effects-bound
					  :test #'equal)))
    (setf (recursive-sclause-conditions-intersection recursive-base-skill)
	  (unsubst-bindings base-bindings conditions-intersect)
	  (recursive-sclause-effects-intersection recursive-base-skill)
	  (unsubst-bindings base-bindings effects-intersect))
    (values (unsubst-bindings new-arg-bindings conditions-intersect)
	    (unsubst-bindings new-arg-bindings effects-intersect))))

(defun new-recursive-macro-name (&optional name) 
  (if name
	(intern (symbol-name (make-symbol (string-upcase (format NIL "REC-MACRO-~A" name)))))
	(intern (symbol-name (gensym "RECURSIVE-MACRO-")))))

(defun new-macro-name (&optional name)
  (if name
      (intern (symbol-name (make-symbol (string-upcase (format NIL "Macro-~A" name)))))
      (intern (symbol-name (gensym "MACRO-")))))

(defun new-var-name () (intern (symbol-name (gensym "?VAR"))))

(defun skill-name (skill)
  (car (sclause-head skill)))

(defun skill-named (name)
  ;; hmmm - could be multiple skills with the same "name"
  ;; this ALWAYS returns the most recent one added
  (loop for skill in sltm*
     for skill-name = (skill-name skill)
     when (eq name skill-name)
     do (return skill)))

(defun wrapper-p (skill)
  (assoc (skill-name skill) *wrapper->skill-list*))

(defun wrapped-p (skill)
  (rassoc (skill-name skill) *wrapper->skill-list*))

(defun copy-skill-with-new-name (skill new-name)
  (make-recursive-sclause :head (cons new-name (cdr (sclause-head skill)))
		:percepts (sclause-percepts skill)
		:tests (sclause-tests skill)
		:conditions (sclause-conditions skill)
		:effects (sclause-effects skill)
		:subskills (sclause-subskills skill)
		:action (sclause-action skill)))

(defun right-most-skill (skill)
  (let* ((subskills (sclause-subskills skill))
	 (right-skill-name (when subskills (first (first (last subskills))))))
    (if (null subskills)
	skill
	(right-most-skill (skill-named right-skill-name)))))

(defun wrapper-with-same-final-skill (skill)
  (let ((right-most-skill (right-most-skill skill)))
    (loop for (wrapper . wrapped-skill)
       in *wrapper->skill-list*
       for right-most-wrapped-skill = (right-most-skill (skill-named wrapped-skill))
       when (equal right-most-wrapped-skill right-most-skill)
;;	collect wrapper))) 
       do (return (skill-named wrapper)))))

(defun wrapper (skill &optional name)
  ;; if skill is a wrapper, return it
  ;; else if skill has a wrapper, return wrapper
  ;; else create a new wrapper for skill, return wrapper and new bindings
  (let ((skill-name (skill-name skill)))
    (cond ((wrapper-p skill)
	   skill)
	  ((wrapped-p skill)
	   (let ((wrapper (skill-named (car (wrapped-p skill)))))
	     (values wrapper (loop for orig in (rest (sclause-head skill))
				for new in (rest (sclause-head wrapper))
				  collect `(,new . ,orig)))))
	  #+WRAP-UP-RM-S-WITH-SAME-FINAL-SKILL
	  ((and (wrapper-with-same-final-skill skill)
		(= (length (sclause-head skill)) 
		   (length (sclause-head (wrapper-with-same-final-skill skill)))))
	   (let* ((existing-wrapper (wrapper-with-same-final-skill skill))
		  (copy-of-wrapper (copy-skill existing-wrapper)))
	     (with-slots (head id subskills conditions effects
			       conditions-intersection effects-intersection)
		 copy-of-wrapper
	       (substitute-new-for-existing-vars 
		copy-of-wrapper
		(loop for x from 1 to (- (length head) 2)
		   collect `(,(nth x (sclause-head skill)) . ,(nth x head))))
	       ;; wrapper now has skills vars
	       (setf subskills (list (sclause-head skill))
		     conditions (sclause-conditions skill)
		     effects (sclause-effects skill))
	       (multiple-value-bind (new-cond-intersect new-effects-intersect)
		   (intersect-conds&effects existing-wrapper 
					    ;; new-args
					    (rest (sclause-head copy-of-wrapper))
					    ;; conditions
					    (sclause-conditions copy-of-wrapper)
					    ;; effects
					    (sclause-effects copy-of-wrapper))
		 (setf conditions-intersection new-cond-intersect
		       effects-intersection new-effects-intersect)))
	     (register-new-skill copy-of-wrapper)))
	  (t
	   (let ((new-wrapper (copy-skill-with-new-name
			       skill 
			       (new-recursive-macro-name name))))
	     (setf (sclause-subskills new-wrapper) (list (sclause-head skill))
		   (sclause-action new-wrapper) NIL
		   (sclause-percepts new-wrapper) NIL)
	     (push (cons (skill-name new-wrapper) skill-name) *wrapper->skill-list*)
	     (register-new-skill new-wrapper))))))

(defun right-sub-skill-name (skill)
  (caar (last (sclause-subskills skill))))

(defun left-sub-skill-name (skill)
  (caar (sclause-subskills skill)))

(defun head-name (head) (car head))
(defun head-args (head) (rest head))

;; the conditions
;; for the macro should be the conditions of the left skill plus those
;; conditions of the right skill that are not achieved by the effects of
;; the left skill. -Pat

;; Definitions:
;;  + left subskill of new macro = LS
;;  + right subskill of new macro = RS
;;  + conditions of each = CLS and CRS respectively
;;  + ditto ELS and ERS
;;  + MC and ME are the conditions and effects of the new macro.
;;
;; To generate MC and ME:
;; 1. naively, MC' = CLS, ME' = ELS
;; 2. MC = MC' + <all x such that x is a member of CRS, and not a member of ELS>
;; 3. ME = ME' + <all x such that x is a member of ELS, and not a member of CRS>
(defun not-unify (x y)
  (not (unify x y)))

(defun compose-conditions (first-conds second-conds first-effects 
			   first-bindings second-bindings)
  (setq first-conds (subst-bindings first-bindings first-conds))
  (setq second-conds (subst-bindings second-bindings second-conds))
  (setq first-effects (subst-bindings first-bindings first-effects))
  (let ((result first-conds))
    (do ((snext (car second-conds) (car second-conds)))
	((null second-conds)
	 result)
      (cond ((and (eq (car snext) 'not)
		  (matches-any-not snext first-effects))
	     nil)
	    ((member snext first-effects :test 'equal)
	     nil)
	    (t
	     ;; can't be unified with something already there
	     (pushnew snext result :test #'unify)))
      (pop second-conds))))

(defun compose-effects (first-effects second-effects first-bindings second-bindings
			composed-conditions)
  (setq first-effects (subst-bindings first-bindings first-effects))
  (setq second-effects (subst-bindings second-bindings second-effects))
  (let ((result (loop for e 
		   in second-effects 
		   when (not (member e composed-conditions :test #'unify))
		   collect e)))
    (do ((fnext (car first-effects) (car first-effects)))
	((null first-effects)
	 result)
      (cond ((and (eq (car fnext) 'not)
		  (matches-any-pos fnext second-effects)) nil)
	    ((matches-any-neg fnext second-effects) nil)
	    ((not (member fnext composed-conditions :test #'unify))
	     (push fnext result)))
      (pop first-effects))))

;; bindings from variablized constants
(defun collect-variablized-constants-bindings (macro-skill &optional (include-const ()))
  (let* ((variables (collect-skill-variables macro-skill)))
    (remove-duplicates
     (loop for var
	in variables
	for const = (constant-from-variable var)
	when (or (and include-const (member const include-const))
		 (null include-const))
	collect (cons var const))
     :test #'equal)))

;;; The following three functions were implemented to ensure that duplicate
;;; skills were not created.
(defun bindings-p (x)
  (and x
       (listp x)
       (loop for x1 in x
	    unless (and (consp x1) (not (listp (cdr x1))))
	    do (return NIL)
	    finally (return T))))

(defun find-consistent-bindings (bind-1-set set-bind-sets)
  (cond ;; (f-c-b nil nil)
    ((or (and (null bind-1-set) (null set-bind-sets))
	 (null bind-1-set))
     NIL)
    ;; (f-c-b '((a . b) ...) '((x . c) ...))
    ((and (bindings-p bind-1-set) (null set-bind-sets))
     bind-1-set)
    ((and (bindings-p bind-1-set) (bindings-p set-bind-sets))
     (let ((bindings (remove-duplicates (append bind-1-set set-bind-sets) :test #'equal)))
       (when (consistent-re-bindings-p bindings)
	 bindings)))
    ;; (f-c-b '((a . b) ...) '(((x . c) ...) ((f . i) ...) ... ))
    ((bindings-p bind-1-set)
     (let ((bindings (find-consistent-bindings bind-1-set (first set-bind-sets))))
       (when bindings
	 (find-consistent-bindings bindings (rest set-bind-sets)))))
    ;; (f-c-b '(((a . b) ...) ((d . e) ...) ... ) '(((x . c) ...) ((f . i) ...) ... ))
    (T 
     (let ((bindings (find-consistent-bindings (first bind-1-set) set-bind-sets)))
       (if bindings
	   bindings
	   (find-consistent-bindings (rest bind-1-set) set-bind-sets))))))

(defun clause-lists-match-p (c1 c2 &key (test #'unify) c2->c1)
  ;; returns unambiguous bindings - e.g.
  ;; (CLAUSE-LISTS-MATCH-P
  ;;   '((NOT (ON ?ANY ?X)) (ON-TABLE ?X ?TABLE) (NOT (ON ?ANY ?Y))
  ;;     (NOT (HOLDING ?ANY2)))
  ;;   '((NOT (ON ?ANY ?B)) (ON-TABLE ?A ?TABLE) (NOT (ON ?ANY ?A))
  ;;     (NOT (HOLDING ?ANY2))))
  ;; => ((?X . ?A) (?Y . ?B))
  (let ((c1-mapped (loop for (x . y) in c2->c1 collect y)))
    (if (and (null c1) (null c2))
	(or c2->c1 no-bindings)
	(when (= (length c1) (length c2))
	  (loop for x in c1
	     for bindings = (loop for y in (subst-bindings c2->c1 c2)
			       for binding = (funcall test x y)
			       if (and binding (equal binding no-bindings))
			       do (return no-bindings)
			       else when binding
			       collect (loop for (b1 . b2) in binding 
					  unless (member b1 c1-mapped :test #'eql)
					  collect (cons b1 b2) into alt-bindings
					  finally (return alt-bindings)))
					;when (and bindings (not (equal bindings no-bindings)))
	     if (null bindings)
	     do (return NIL)
	     else unless (equal bindings no-bindings)
	     collect bindings into additional-bindings
	     finally (return (if additional-bindings 
				 (let ((added-bindings (find-consistent-bindings 
							(first additional-bindings)
							(rest additional-bindings))))
				   (when added-bindings
				     (append (reverse-map added-bindings) c2->c1)))
				 c2->c1)))))))
	     ;; consistent bindings amongst collections?

(defun found-and-subd (clause old->new-var-map &optional (found NIL))
  ;; Have to test FOUND and return if its T regardless
  (cond ((null clause)
	 nil)
	((symbolp clause) clause)
	((eq 'not (first clause))
	 (let ((clause (found-and-subd (rest clause) old->new-var-map found)))
	   (when clause (list 'not clause))))
	;;
	((or (variablep (first clause)) (symbolp (first clause)))
	 (let ((first (cdr (assoc (first clause) old->new-var-map))))
	   (if first
	       (cons first
		     (found-and-subd (cdr clause) old->new-var-map T))
	       (let ((rest (found-and-subd (cdr clause) old->new-var-map found)))
		 (when (or rest found)
		   (cons (first clause) rest))))))
	;; 
	((consp (first clause))
	 (let ((first (found-and-subd (first clause) old->new-var-map found))
	       (rest (found-and-subd (cdr clause) old->new-var-map found)))
	   (if (and first rest)
	       (if (consp (first rest))
		   (cons first rest)
		   (list first rest))
	       (if first
		   first
		   rest))))
	(t
	 (let ((rest (found-and-subd (cdr clause) old->new-var-map found)))
	   (when rest
	     (cons (car clause) rest))))))

(defun sub-new-for-existing (clause new->exist-map)
  (cond ((null clause)
	 nil)
	((atom clause) clause)
	((eq 'not (first clause))
	 (cons 'not (sub-new-for-existing (rest clause) new->exist-map)))
	((or (variablep (first clause)) (symbolp (first clause)))
	 (cons (or (car (rassoc (first clause) new->exist-map))
		   (first clause)) ;; no new binding, keep original variable
	       (sub-new-for-existing (cdr clause) new->exist-map)))
	((consp (first clause))
	 (cons (sub-new-for-existing (first clause) new->exist-map)
	       (sub-new-for-existing (cdr clause) new->exist-map)))
	(t
	 (cons (car clause)
	       (sub-new-for-existing (cdr clause) new->exist-map)))))

(defmethod substitute-new-for-existing-vars ((skill sclause) new->exist-map)
  (setf (sclause-head skill)
	(sub-new-for-existing (sclause-head skill) new->exist-map)
	(sclause-conditions skill)
	(sub-new-for-existing (sclause-conditions skill) new->exist-map)
	(sclause-effects skill)
	(sub-new-for-existing (sclause-effects skill) new->exist-map)
	(sclause-subskills skill)
	(sub-new-for-existing (sclause-subskills skill) new->exist-map))
  skill)

(defmethod substitute-new-for-existing-vars ((skill recursive-sclause) new->exist-map)
  (setf (recursive-sclause-conditions-intersection skill)
	(sub-new-for-existing (recursive-sclause-conditions-intersection skill) new->exist-map)
	(recursive-sclause-effects-intersection skill)
	(sub-new-for-existing (recursive-sclause-effects-intersection skill) new->exist-map))
  (call-next-method))

(defmethod copy-skill ((sclause sclause))
  (with-slots (head id percepts tests conditions effects subskills action) 
      sclause
    (make-sclause :head (copy-tree head)
		  :id (copy-tree id)
		  :percepts (copy-tree percepts)
		  :tests (copy-tree tests)
		  :conditions (copy-tree conditions)
		  :effects (copy-tree effects)
		  :subskills (copy-tree subskills)
		  :action (copy-tree action))))

(defmethod copy-skill ((sclause recursive-sclause))
  (with-slots (head id percepts tests conditions effects subskills action
		    conditions-intersection effects-intersection)
      sclause
    (make-recursive-sclause :head (copy-tree head)
		  :id (copy-tree id)
		  :percepts (copy-tree percepts)
		  :tests (copy-tree tests)
		  :conditions (copy-tree conditions)
		  :effects (copy-tree effects)
		  :subskills (copy-tree subskills)
		  :action (copy-tree action)
		  :conditions-intersection (copy-tree conditions-intersection)
		  :effects-intersection (copy-tree effects-intersection))))

(defun register-new-skill (skill-clause)
  (let* ((new-skill-clause (copy-skill skill-clause))
	 (new->exist-map (loop for variable
			    in (collect-skill-variables new-skill-clause) ; new->exist map
			    collect (cons (new-var-name) variable))))
    (setf (sclause-id (substitute-new-for-existing-vars
		       new-skill-clause	; skill-clause as given
		       new->exist-map)) ; new-skill-clause w/gensyms
	  (incf id-count*))
    (setf sltm* (append sltm* (list new-skill-clause)))
    #+IGNORE
    (setf (sclause-id skill-clause) (sclause-id new-skill-clause))
    (values new-skill-clause new->exist-map)))

(defun consistent-re-bindings-p (re-bindings)
  (let ((orig-length (length (remove-duplicates re-bindings :test #'equal))))
    (multiple-value-bind (first second)
	(loop for (x . y) in re-bindings
	     collect x into first
	     collect y into second
	     finally (return (values (remove-duplicates first) (remove-duplicates second))))
      (and (= orig-length (length first))
	   (= orig-length (length second))))))

(defun find-or-make-sclause (sclause-list &key head id percepts tests
			     conditions effects subskills action (skip-subskills nil))
  (let ((temp (make-sclause :head head :id id :percepts percepts :tests tests
			    :conditions conditions :effects effects :subskills subskills
			    :action action)))
    (loop for sc 
       in sclause-list
       for head? = (unify (cdr (sclause-head sc)) (cdr head))
;       for percepts? = (when head? (clause-lists-match-p percepts (sclause-percepts sc)))
       ;; tests?
       for conditions? = (when head? ; percepts?
			   (clause-lists-match-p conditions (sclause-conditions sc)
						 :c2->c1 head?))
       for effects? = (when conditions? (clause-lists-match-p effects (sclause-effects sc)
							      :c2->c1 conditions?))
       for subskills? = (when effects?
			  (if skip-subskills 
			      '((t . t))
			      (clause-lists-match-p subskills (sclause-subskills sc)
						 :c2->c1 effects?)))
       for action? = (when subskills? (clause-lists-match-p action (sclause-action sc)
						 :c2->c1 subskills?))
       ;; action? can only be non-NIL if (and head? percepts? conditions? effects? subskills?)
       for re-bindings = (progn #+DEBUG
				(format T "head?: ~A~%conditions?: ~A~%effects?: ~A~%subskills?: ~A~%~
                                      action?: ~A~%" head? conditions? effects? subskills? 
				      action?)
				action?)
	 #+SIMPLER (when action?
			   #-DEBUG
			   (format T "head?: ~A~%conditions?: ~A~%effects?: ~A~%subskills?: ~A~%~
                                      action?: ~A~%" head? conditions? effects? subskills? 
				      action?)
			   (remove-duplicates
			    (append head? conditions? effects? subskills? action?)
			    :test #'equal))
       when re-bindings #+SIMPLER (and action? (consistent-re-bindings-p re-bindings))
;; that is, we found an existing, matching skill, so ...
       do ;; ... just return temp, but replace the id with the sc's id ...
	 ;; rebindings: temp->skill
       (return (values sc re-bindings
		       #+IGNORE
	       (progn (setf (sclause-id temp) (sclause-id sc)
			    (sclause-head temp) (append (list (car (sclause-head sc)))
							(cdr (sclause-head temp))))
		      temp)))
       #+IGNORE
       (let ((re-bindings (remove-duplicates
			   (append head? percepts? conditions? effects? subskills? action?)
			   :test #'equal)))
	 (return (values (substitute-new-for-existing-vars (copy-skill sc) re-bindings)
			 re-bindings)))
       finally
       ;; let's "register" the skill here ... and as part of registry, 
       ;; make vars gensyms in the registered version, but return temp w/current vars
;;       (setf (sclause-id temp) (register-new-skill temp))
;;       (return temp))))
	 (return (multiple-value-bind (skill re-bindings) 
		     (register-new-skill temp)
		   (values skill re-bindings))))))

;; check wrapper->skill-list to see if this skill has already been wrapped;
;;   IF NOT create new macro skill from skill of given intention and add to wrapper->skill-list
;;   IF FOUND use the found macro.
;; RETURN new intention based on macro skill and bindings of given intention.
(defun make-macro-base (intention &optional name)
  (let ((orig-skill (skill intention)))
    (with-slots (head conditions effects subskills)
	intention
      (multiple-value-bind (wrap-skill re-bindings) ; re-bindings are new->old
	  (wrapper orig-skill name)
	(let ((given-bindings (intention-bindings intention)))
	  (create-intention 
	   wrap-skill
	   ;; use re-bindings to replace vars in given with those of skill
	   (sub-new-for-existing given-bindings re-bindings)))))))

(defun reverse-map (alist)
  (loop for (x . y) in alist
       collect (cons y x)))

;;; MAKE-MACRO (INTENT-1 &optional INTENT-2 &key (left-recursive? T))
       ;; that is, create a new skill (and associated intention) with 
       ;;   left sub-skill = (skill intent-1) and
       ;;   right sub-skill = (skill intent-2)
       ;; return new intention (using new skill); 
       ;; SIDE EFFECTS: add new skill (instantiated in new-intention) to sltm*;
       ;;               if not recursive, add new name to name->left(right)-most-subskill map
       ;; HEAD (name arglist) of new intention/skill determined as follows:
       ;;      recursion-type = :left
       ;;         intent-1's right sub-skill and intent-2's skill are same
       ;;         -> name is from intent-1, args from intent-2
       ;;      OR
       ;;      recursion-type = :right
       ;;         intent-1's skill and intent-2's left sub-skill are same
       ;;         ->name is from intent-2, args from intent-1)
       ;;      OR
       ;;      gensym name (no recursion here),
       ;;         and args from intent-1 (recursion-type = :left) or intent-2


;;; skill's by name or by id?  the subskills list (in skills and intentions) is a list of heads
;;; with the skills identified only by name (as the first member of the subskill head list).
;;; In the case of creating a
;;; recursive skill, at least two skills will be created with the same name.  Issue: which skill
;;; should be called (determined by conditions?); 
;;; Intent always shares id of skill it is created from, so at "run time" it will be clear which 
;;; skill to run, but not necessarily which sub-skill(s).

(defun make-macro (intention-1 intention-2 recursion-type &optional name)
  ;; recursive macro?
  (let* ((skill-1 (skill intention-1))
	 (skill-1-name (skill-name skill-1))
	 (skill-2 (skill intention-2))
	 (skill-2-name (skill-name skill-2))
	 (recursive-p T))
    (unless (or (case recursion-type
		  (:left (and (eq (right-sub-skill-name skill-1) skill-2-name)
			      (or (wrapper-p skill-1) ; call to recur. base, call/mk r. case
				  (eq (left-sub-skill-name skill-1)
				      skill-1-name)))) ; call to existing recursive case
		  (:right (and (eq skill-1-name (left-sub-skill-name skill-2))
			       (or (wrapper-p skill-2) ; call to recur. base, call/mk r. case
				   (eq (right-sub-skill-name skill-2) 
				       skill-2-name))))) ; call to existing recursive case
		(and (intersection (rest (intention-head intention-1)) ; shared operands and
				   (rest (intention-head intention-2))) ; shared skills implies
		     (eq skill-1-name skill-2-name))) ; FOUND new base macro
      (setf recursive-p NIL))
    ;; the story up until now:
    ;; -a- call to existing recursive base
    ;; -b- call to existing recursive case
    ;; -c- new recursive base created
    ;; -d- not recursive, new macro created
    ;; what to do: replace given pair of intents with a macro call
    (if recursive-p			; then a, b, or c
	(if (or (and (eq recursion-type :left) (wrapper-p skill-1))
		(and (eq recursion-type :right) (wrapper-p skill-2)))
	    ;; -a- (intent-1 intent-2) :: 
	    ;;      + (base-skill-1 skill-vars) (macro-skill-2 macro-vars) vars semantically 
	    ;;        identical, syntactically different
	    ;;      + find/make recursive case of recursive base;
	    ;;      + new head name is intent-2 head name; parameters from head-1; 
	    ;;      + intent-1 bindings must be added to match "non-head" var bindings in cond's & eff's;
	    ;;      => new intent, same head as intent-2, but additional bindings from intent-1
	    ;; -b- (intent-1 intent-2)
	    ;;      + recursive case is intent-2 skill;
	    ;;      + intent-1 bindings must replace "non-head" var bindings in conditions and effects;
	    ;;      => new intent, same head as intent-2, but additional bindings from intent-1 (like a)
	    (recursive-case intention-1 intention-2 recursion-type)
	    ;; -c- (intent-1 intent-2)
	    ;;     + (skill intent-1) = (skill intent-2)
	    ;;     => make base of skill, and case of skill + base
	    (if (eq recursion-type :left)
		(recursive-case (make-macro-base intention-1 name) intention-2 :left)
		(recursive-case intention-1 (make-macro-base intention-2 name) :right)))
	;; -d- (intent-1 intent-2)
	;;     + new macro with merged conditions and effects of intent-1 and intent-2
	;;     => new intent with intent-1 & intent-2 bindings bound correctly
	(make-normal-macro intention-1 intention-2 name)) ; not recursive
    ))

(defun recursive-case (intent-1 intent-2 recursion-type)
  ;; return new intention with skill being the recursive case
  (let ((recur-case-skill 
	 (recursive-case-skill (if (eq recursion-type :right)
				   (skill intent-2)
				   (skill intent-1)))))
    (if (not recur-case-skill)
	(make-recursive-case intent-1 intent-2 recursion-type)
	(create-intention recur-case-skill
			  ;; infer bindings from intentso
			  (remove-if
			   #'(lambda (x) (and (variable-p (car x)) 
					      (variable-p (cdr x))))
			   (remove-duplicates
			    (append
			     (loop for var
				in (rest (first (sclause-subskills recur-case-skill)))
				for value in (rest (intention-head intent-1))
				collect (cons var value))
			     (loop for var
				in (rest (second (sclause-subskills recur-case-skill)))
				for value in (rest (intention-head intent-2))
				collect (cons var value)))
			    :test #'equal))))))

(defun recursive-case-skill (macro-base-skill)
  (find-skill-from-id (cdr (assoc (sclause-id macro-base-skill)
				  *recursive-base->recursive-case-skill*))))

(defun unvariablize (var)
	   (let ((var-str (symbol-name var)))
	     (if (char= #\? (aref var-str 0))
		 (intern (subseq var-str 1))
		 var)))

#+OLD
(defun make-normal-macro (intention-1 intention-2)
  (let* ((h1 (intention-head intention-1))
	 (c1 (intention-conditions intention-1))
	 (e1 (intention-effects intention-1))
	 (b1 (intention-bindings intention-1))
	 (h2 (intention-head intention-2))
	 (c2 (intention-conditions intention-2))
	 (e2 (intention-effects intention-2))
	 (b2 (intention-bindings intention-2))
	 (c3 (compose-conditions c1 c2 e1 b1 b2))
	 (e3 (compose-effects e1 e2 b1 b2 c3))
	 (new-head-name (new-macro-name))
	 (new-head-args (variablize-constants-all (remove-duplicates
						   (append (rest h1) 
							   (rest h2)))))
	 (new-head (push new-head-name new-head-args)))
    (multiple-value-bind (skill bindings)
	(find-or-make-sclause sltm*
			      :head new-head
			      :conditions (variablize-constants-all c3)
			      :effects (variablize-constants-all e3)
			      :subskills (list (variablize-constants h1)
					       (variablize-constants h2))
			      :action NIL)
      (let ((new-bindings (loop for (var . query-const) in bindings
			     collect (cons var (unvariablize query-const)))))
	(make-intention :head (subst-bindings new-bindings (sclause-head skill))
			:id (sclause-id skill)
			:bindings new-bindings
			:conditions c3
			:effects e3
			:subskills (list h1 h2)
			:remaining-subskills (list h1 h2)
			:action NIL)))))

#-NEW-BUT-IS
(defun make-normal-macro (intention-1 intention-2 &optional name)
  ;; need to do something if subskill(s) is(are) a recursive macro(s)
  ;; UH OH what about right recursive in make-recursive-macro UH OH
  ;; if macro is LEFT subskill then its contrib to condition may be different
  ;; if recursive macro is RIGHT subskill then its contrib to 
  (let* ((int-1-recursive? (typep (skill intention-1) 'recursive-sclause))
	 (int-2-recursive? (typep (skill intention-2) 'recursive-sclause))
	 (h1 (intention-head intention-1))
	 (b1 (intention-bindings intention-1))
	 (c1 (if int-1-recursive?
		 (subst-bindings b1 (recursive-sclause-conditions-intersection
				     (skill intention-1)))
		 (intention-conditions intention-1)))
	 (e1 (if int-1-recursive?
		 (subst-bindings b1 (recursive-sclause-effects-intersection
				     (skill intention-1)))
		 (intention-effects intention-1)))
	 (h2 (intention-head intention-2))
	 (b2 (intention-bindings intention-2))
	 (c2 (if int-2-recursive?
		 (subst-bindings b2 (recursive-sclause-conditions-intersection
				     (skill intention-2)))
		 (intention-conditions intention-2)))
	 (e2 (if int-2-recursive?
		 (subst-bindings b2 (recursive-sclause-effects-intersection
				     (skill intention-2)))
		 (intention-effects intention-2)))
	 (c3 (compose-conditions c1 c2 e1 b1 b2))
	 (e3 (compose-effects e1 e2 b1 b2 c3))
	 (new-head-name (new-macro-name name))
	 (new-head-args (variablize-constants-all (remove-duplicates
						   (append (rest h1) 
							   (rest h2)))))
	 (new-head (push new-head-name new-head-args)))
    (multiple-value-bind (skill bindings)
	(find-or-make-sclause sltm*
			      :head new-head
			      :conditions (variablize-constants-all c3)
			      :effects (variablize-constants-all e3)
			      :subskills (list (variablize-constants h1)
					       (variablize-constants h2))
			      :action NIL)
      (let ((new-bindings (loop for (var . query-const) in bindings
			     collect (cons var (unvariablize query-const)))))
	(make-intention :head (subst-bindings new-bindings (sclause-head skill))
			:id (sclause-id skill)
			:bindings new-bindings
			:conditions c3
			:effects e3
			:subskills (list h1 h2)
			:remaining-subskills (list h1 h2)
			:action NIL)))))

(defun replace-vars (clause new-var-map->var)
  (sub-new-for-existing clause (reverse-map new-var-map->var)))

(defun variablized-constant-bindings (bindings)
  (loop for (var . val) in bindings
     collect (cons (variablize-constant val) val)))

(defun additional-clauses (clauses constants->new-vars given-bindings)
  (sub-new-for-existing (found-and-subd clauses constants->new-vars t)
			given-bindings))

;; DAMN this is thing is huge and ugly ...
;; so what if the "skill" (that is, for left recursion the right subskill, for right recursion
;; the left subskill) is ANOTHER recursive macro?  Then we should us its
;; [conditions|effects]-intersection for combining to create this macros [conditions|effects].
;; And true for make-macro-base.
(defun make-recursive-case (intent-1 intent-2 recursion-type)
  (assert (wrapper-p (skill (if (eq recursion-type :right) 
				intent-2
				intent-1))))
  (let* ((intent-1-bindings (intention-bindings intent-1))
	 (intent-2-bindings (intention-bindings intent-2))
	 (skill-1 (skill intent-1))
	 (skill-2 (skill intent-2)))
    ;; take underlying skills, get things renamed and bound properly, 
    ;; create new case skill with subskill calls using names from new case
    ;; create new intention, use newly created case skill w/ bindings from intent-1 & intent-2
    ;;   for recursion-type = :right ...
    ;; given 1-B as bindings for intent-1, and 2-B,
    ;; find X such that X is bound in 1-B and 2-B:
    ;; - map var bound to X in 2-B (shared) to the var in 1-B (2-B-s->1-B-var)
    ;; - map the names of unshared 2-B vars (2-B-u) to gen syms (2-B-u->new-vars-map)
    ;; - make copies of all conditions and effects which involve unshared (2-B-u) vars
    ;;   and change the names using 2-B-u->new-vars-map
    ;; - create a skill with same skill as 2, but with vars from 1
    ;;   and conditions and effects from 1, plus conditions and effects from previous step
    ;;   and subskill-1 with skill and vars as in intent-1
    ;;   and subskill-2 as skill in 2, but with new var names (2-b-u->new-vars-map)
    (case recursion-type 
      (additional-clauses)
      (learn-clear-and-stack-block-macro)
      (:right
       (multiple-value-bind (2-B-s-c->1-B-var 2-B-u-c->new-vars-map)
	   (loop for (2-var . 2-bind) in intent-2-bindings
	      for shared-1-var-bind = (rassoc 2-bind intent-1-bindings)
	      if shared-1-var-bind
	      collect (cons 2-bind (car shared-1-var-bind)) into 2-B-s-c->1-B-var
	      else collect (cons 2-bind (new-var-name)) into 2-B-u-c->new-vars-map
	      finally (return (values 2-B-s-c->1-B-var 2-B-u-c->new-vars-map)))
	 (let* ((test-bindings (append intent-1-bindings
				       (reverse-bindings 2-B-u-c->new-vars-map)))
		;; conditions from recursive call
		(additional-conditions (additional-clauses (intention-conditions intent-2)
							   2-B-u-c->new-vars-map
							   intent-1-bindings))
		;; effects from recursive call
		(additional-effects (additional-clauses (intention-effects intent-2)
							2-B-u-c->new-vars-map
							intent-1-bindings))
		;; combine skill_conditions + (recursive-call_conditions - skill_effects)
		(combined-conditions (remove-duplicates
				      (unsubst-bindings
				       test-bindings
				       (append (copy-tree (sclause-conditions skill-1))
					       (loop for cond
						  in (subst-bindings
						      test-bindings
						      additional-conditions)
						  with subd-skill-effects =
						  (subst-bindings test-bindings
								  (copy-tree (sclause-effects
									      skill-1)))
						  unless (member
							  cond 
							  subd-skill-effects
							  :test #'unify)
						  collect cond)))
				      :test #'equal))
		(combined-effects (remove-duplicates
				   (append additional-effects
					   (copy-tree (sclause-effects skill-1)))
				   :test #'equal))
		(new-recursive-case-skill
		 (multiple-value-bind (intersect-conds intersect-effects)
		     (intersect-conds&effects skill-2 (rest (sclause-head skill-1))
					      combined-conditions combined-effects)
		   (make-recursive-sclause
		    :head (cons (first (sclause-head skill-2)) 
				(copy-list (rest (sclause-head skill-1))))
		    :tests (copy-tree (sclause-tests skill-2))
		    :conditions combined-conditions
		    :effects combined-effects
		    :conditions-intersection intersect-conds
		    :effects-intersection intersect-effects
		    :subskills 
		    (list 
		     (copy-list (sclause-head skill-1))
		     (replace-vars (copy-list (intention-head intent-2))
				   (append 2-B-s-c->1-B-var 2-B-u-c->new-vars-map)))))))
	   (multiple-value-bind (new-regd-skill unregd->regd-var-map)
	       (register-new-skill new-recursive-case-skill)
	     (push (cons (sclause-id skill-2) (sclause-id new-regd-skill))
		   *recursive-base->recursive-case-skill*)
	     (let* ((regd-bindings (sub-new-for-existing test-bindings unregd->regd-var-map))
		    (subskills-list (list (subst-bindings 
					   regd-bindings
					   (copy-list (first (sclause-subskills
							      new-regd-skill))))
					  (subst-bindings 
					   regd-bindings
					   (copy-list 
					    (second (sclause-subskills
						     new-regd-skill)))))))
	       (make-intention :id (sclause-id new-regd-skill)
			       :head (subst-bindings regd-bindings 
						     (sclause-head new-regd-skill))
			       :conditions (subst-bindings regd-bindings 
							   (sclause-conditions new-regd-skill))
			       :effects (subst-bindings regd-bindings
							(sclause-effects new-regd-skill))
			       :bindings regd-bindings
			       :subskills subskills-list
			       :remaining-subskills (copy-tree subskills-list)))))))
      (:left
       ;; 2-B-s-c->1-b-var => 2 -> recursive-call : s -> shared : c -> constant :
       ;;                     1 -> base-skill : var -> var
       ;;                     recur-call-shared-const->base-skill-var
       ;;                     r-c-shared-const->b-s-var
       ;; 2-B-u-c->new-vars-map => r-c-unshared-const->new-var
       ;; arg r-c-intent (intent-2)
       ;; arg b-s-intent (intent-1)
       ;; base-skill (skill-1)
       ;; recursive-skill (skill-2)
       (let* ((r-c-intent intent-1)
	      (r-c-bindings (intention-bindings r-c-intent))
	      (b-s-intent intent-2)
	      (b-s-intent-bindings (intention-bindings b-s-intent))
	      (base-skill (skill b-s-intent))
	      (recursive-skill (skill r-c-intent)))
	 (multiple-value-bind (r-c-shared-const->b-s-var r-c-unshared-const->new-var)
	     (loop for (r-c-var . r-c-bind) in r-c-bindings
		for base-skill-var-bind = (rassoc r-c-bind b-s-intent-bindings)
		if base-skill-var-bind
		collect (cons r-c-bind (car base-skill-var-bind)) into r-c-shared-const->b-s-var
		else collect (cons r-c-bind (new-var-name)) into r-c-unshared-const->new-var
		finally (return (values r-c-shared-const->b-s-var r-c-unshared-const->new-var)))
	   (let* ((test-bindings (append b-s-intent-bindings
					 (reverse-bindings r-c-unshared-const->new-var)))
		  ;; call to recursive-case adds these conditions
		  (additional-conditions (additional-clauses (intention-conditions r-c-intent)
							     r-c-unshared-const->new-var
							     b-s-intent-bindings))
		  ;; call to recursive-case has these effects
		  (additional-effects (additional-clauses (intention-effects r-c-intent)
							  r-c-unshared-const->new-var
							  b-s-intent-bindings))
		  ;; recursive-case called first, so only combine conditions of the base-skill
		  ;; (called second) which aren't met by recursive-case effects.
		  (combined-conditions-1 (remove-duplicates
					  (append 
					   additional-conditions
					   (unsubst-bindings 
					    test-bindings
					    (loop for cond
					       in (subst-bindings 
						   test-bindings
						   (copy-tree
						    (sclause-conditions base-skill)))
					       with subd-add-effects =
					       (subst-bindings test-bindings
							       additional-effects)
					       unless (member 
						       cond 
						       subd-add-effects
						       :test #'unify)
					       collect cond)))
					  :test #'equal))
		  (combined-effects (remove-duplicates
				     (append additional-effects
					     (copy-tree (sclause-effects base-skill)))
				     :test #'equal))
		  ;; only these bindings are available in the recursive call
		  (recursive-test-bindings (reverse-bindings
					    (append r-c-shared-const->b-s-var
						    r-c-unshared-const->new-var)))
		  ;; recursive application of should eliminate conditions from effects of 
		  ;; next application of recursive call: (foo A B) calls (foo B C) (skill A B);
		  ;; so effect of (foo B C) eliminates any condition set by (skill A B) if
		  ;; they're the same (e.g. eff (foo B C) is (x ?y B), and cond of (skill A B)
		  ;; is (x A B)) - then that cond of (skill A B) should be removed from
		  ;; combined conditions).
		  (combined-conditions (unsubst-bindings
					test-bindings
					(loop for cond 
					   in (subst-bindings 
					        test-bindings
					       combined-conditions-1)
					   ;; effects are from recursive call, so only
					   ;; recursive-test-bindings available
					   with effects = (subst-bindings
							   recursive-test-bindings
							   combined-effects)
					   unless (member cond effects :test #'unify)
					   collect cond)))
		  (new-recursive-case-skill
		   (multiple-value-bind (intersect-conds intersect-effects)
		       (intersect-conds&effects recursive-skill (rest (sclause-head base-skill))
						combined-conditions combined-effects)
		     (make-recursive-sclause
		      :head (cons (first (sclause-head recursive-skill)) 
				  (copy-list (rest (sclause-head base-skill))))
		      :tests (copy-tree (sclause-tests recursive-skill))
		      :conditions combined-conditions
		      :effects combined-effects
		      :conditions-intersection intersect-conds
		      :effects-intersection intersect-effects
		      ;; subskill list reverse of :right case
		      :subskills (list (replace-vars 
					(copy-list (intention-head r-c-intent))
					(append r-c-shared-const->b-s-var
						r-c-unshared-const->new-var))
				       (copy-list (sclause-head base-skill)))))))
	     #+debug
	     (format T "~%test-bindings: ~A~%recursive-test-bindings: ~A~%~
                        r-c-unshared-cons->new-var: ~A~%b-s-intent-bindings: ~A~%~
                        add-cond: ~A~%add-eff: ~A~%bs-cond: ~A~%comb-cond-1: ~A~%~
                        comb-effects: ~A~%comb-cond: ~A~%new-skill: ~A~%"
		     test-bindings recursive-test-bindings
		     r-c-unshared-const->new-var b-s-intent-bindings
		     additional-conditions additional-effects (sclause-conditions base-skill)
		     combined-conditions-1 combined-effects combined-conditions
		     new-recursive-case-skill)
	     (multiple-value-bind (new-regd-skill unregd->regd-var-map)
		 (register-new-skill new-recursive-case-skill)
	       (push (cons (sclause-id recursive-skill) (sclause-id new-regd-skill))
		     *recursive-base->recursive-case-skill*)
	       (let* ((regd-bindings (sub-new-for-existing test-bindings unregd->regd-var-map))
		      (subskills-list (list (subst-bindings 
					     regd-bindings
					     (copy-list (first (sclause-subskills 
								new-regd-skill))))
					    (subst-bindings 
					     regd-bindings
					     (copy-list (second (sclause-subskills
								 new-regd-skill)))))))
		 (make-intention :id (sclause-id new-regd-skill)
				 :head (subst-bindings regd-bindings 
						       (sclause-head new-regd-skill))
				 :conditions (subst-bindings
					      regd-bindings 
					      (sclause-conditions new-regd-skill))
				 :effects (subst-bindings regd-bindings
							  (sclause-effects new-regd-skill))
				 :bindings regd-bindings
				 :subskills subskills-list
				 :remaining-subskills (copy-tree subskills-list)))))))))))
;;; ISSUE - those variables NOT in header ... there are two types, those which represent the 
;;; same thing, those which don(defun build-blocks-world-macros't.  In the blocks world 
;;; pick-up mentions ?any and ?table, stack ()
;;; also mentions ?any and ?table. When combining into pick up and stack, the any in BOTH is
;;; used to ensure a particular block has nothing on top - if they're kept the same, they'll mean
;;; two particular blocks don't have the SAME thing on top. This is wrong.  Similarly, ?table in
;;; both refers to the same table.  In this case, splitting into two two new variables (to avoid
;;; the previous problem) may work ok, but it definitely changes the semantics (ie, ?table =>
;;; ?table1 and ?table2).

;;; ISSUE - using bindings in intentions to discover things that are the same.  This means that
;;; examining skills directly doesn't permit macro "discovery" (vs. learning in the heat of
;;; application).

;;; ISSUE - percepts - I'm pretending they're going away, so I'm not comparing percept fields when
;;; looking for matching skills (find-or-make-sclause).

#+ICARUS-PATCH
(defun make-problem-from-goal-literal-list (list-of-goal-literals)
  (loop with new-problem = (make-problem)
     for objective in list-of-goal-literals
     for new-goal = (make-goal :objective objective)
     do
       (when debug* (print new-goal))
;; this seems unnecessary, and you have to set *print-circle* T if you use it.
;       (setf (goal-problem new-goal) new-problem)
       (push new-goal (problem-goals new-problem))
     finally
     (setf (problem-objectives new-problem)
	   (loop for goal in (problem-goals new-problem)
	      collect (goal-objective goal)))
     (setf (problem-pos-objectives new-problem)
	   (collect-pos-conditions (problem-objectives new-problem)))
     (setf (problem-neg-objectives new-problem)
	   (collect-neg-conditions (problem-objectives new-problem)))
     (return new-problem)))

(defun troll-for-skills-with-identical-effects (skill)
  (let ((effects (sclause-effects skill)))
    (loop for sk in (remove skill sltm* :test #'equal)
	 when (unify effects (sclause-effects sk))
	 collect sk)))

;; alist: (effects-clause . list-of-skills-whose-effects-clause-unifies-with-key)
(defvar *effects->skills* '())

(defun add-to-effects->skills-alist (skill)
  (let* ((effects (sclause-effects skill))
	 (skill-list (cdr (assoc effects *effects->skills* :test #'unify))))
    (if skill-list
	(push skill (cdr (assoc effects *effects->skills* :test #'unify)))
	(push `(,effects . ,(list skill)) *effects->skills*))))

(defun initialize-effects->skills-alist (skill-list)
  (loop for skill in skill-list
       do (add-to-effects->skills-alist skill))
  *effects->skills*)

(defun find-skills-w/same-effects (skill)
  (remove skill (cdr (assoc (sclause-effects skill) *effects->skills* :test #'unify))
	  :test #'equal))

;; DIFFERENT CONDITIONS, SAME EFFECTS - IT'S NOT EFFECTS!!! IT'S RIGHTMOST SKILL!!!
;;                                      effects can include "side-effects" from other skills.
;;                                      so PICK-UP-AND-STACK and UNSTACK-AND-STACK should be
;;                                      interchangeable, but they have different side-effects
;;                                      PICK-UP has block1 no longer on table, UNSTACK has
;;                                      block1 no longer on top of another block.
;; replacing left subskill with other subskill having different conditions, same effects
;; -> different conditions, but same end result
;; -> for a normal macro, create a new macro (with unique or same name? - I like same name)
;;    - same name means vaguer conditions (when involved in skill construction), but means
;;      more ways to achieve the same effects with the same macro (by name).  Unique name
;;      means another way to achieve the same effect. 
;;    - recurse: ie. new macro will have same effects as the old, so new macros can be created 
;;      everywhere its a subskill with new uniquely named macro, or if same name, only the
;;      conditions need to be changed - to the intersection, like a recursive macro).
;; -> if this is the left subskill in right recursive, that is its the basic skill
;;    on which the recursion is founded (in left recursion, the left subskill is the recursive
;;    case):
;;      + create a new recursive case,
;;      + create a new recursive base,
;;      + new conditions for new macro AND modify conditions-intersection for all case
;;        and base instances (concern being the conditions-intersection could be reduced
;;        to trivial)
;;
;; SAME CONDITIONS, DIFFERENT EFFECTS - can't do this for recursion, because the intersection
;; quickly becomes NIL, which means this doesn't do anything - but it does.
;; replacing right subskill with other subskill having same conditions, different effects
;; -> same conditions, but different end result
;; -> for a normal macro, create a new macro with a unique name - recurse (see above)
;;
;; NOTES
;; Could do a lazy implementation - choose subskills on the fly based on needed effects,
;; and current conditions.  This doesn't work so well when recursive-macro involved as the
;; effects-intersection and conditions-intersection won't be involved in selection.
;; 
;; Have to re-learn normal (or recursive) macros learned with old
;; [conditions|effects]-intersection if componenent(s) are recursive macros (in case of
;; recursion, if the component skill is a different recursive macro).  OR maybe just recompute.
;; This is getting to be more and more like a truth maintenance thing.  Sheesh.
;;
;; New macro created: check and see if its effects are identical to other skills. 